; File: DEBUG.LSP  (C)		    03/06/91		Soft Warehouse, Inc.


(IF (EQ *INIT-WINDOW* '*INIT-WINDOW*) (SETQ *INIT-WINDOW* "Debug"))
(SETQ *WINDOW-TYPES* (SORT (ADJOIN "Debug" *WINDOW-TYPES*) 'STRING<))
(SETQ DRIVER 'WINDOWS)

(SETQ *HISTORY-LENGTH* 25)
(SETQ *SHOW-LOAD* T)
(SETQ *DEBUG-FUNCTIONS* NIL)

(DEFUN "Debug" (COMMAND
	FUNCTION BREAK
	*TRACE-HISTORY* *DEBUG-MODE* *BACKTRACE* *DEBUG-ROW* *PRINT-TRACE*
    *FILE-NAME* *LOCAL-DEMONS* *INPUT-FILE* *OUTPUT-FILE* *FREE-STATUS*)
  ((EQ COMMAND 'CREATE-WINDOW)
    (LIST "Debug" NIL NIL NIL "Continuous" NIL 0 NIL) )
  ((EQ COMMAND 'CLOSE-WINDOW)
    (UNTRACE-ALL)
    0 )
  (SETQ *FILE-NAME* ""
	*FREE-STATUS* 'DEBUG-FREE)
  (UNWIND-PROTECT
    (PROGN
      ((EQ COMMAND 'UPDATE-WINDOW)
	(CURRENT-WINDOW T)
	(DEBUG-ROW) )
      ((EQ COMMAND 'DISPLAY)
	(SHOW-PROMPT "Press ESC to abort")
	(CURRENT-DEBUG-WINDOW)
	(TERPRI)
	(CURSOR-ON)
	((LAMBDA (*AUTO-NEWLINE* *INTERRUPT-HOOK*)
	   (CATCH NIL (PRIN1 (EVAL BREAK)))) T 'CONSOLE-INTERRUPT)
	(CURSOR-OFF)
	(DEBUG-ROW) )
      ((OR (EQ COMMAND 'TRACEIN) (EQ COMMAND 'TRACEOUT))
	( ((EQ *DEBUG-MODE* "Off"))
	  (CURRENT-DEBUG-WINDOW)
	  (DISPLAY-TRACE (CAR *TRACE-HISTORY*))
	  (DEBUG-ROW)
	  ((EQ *DEBUG-MODE* "Continuous"))
	  ((EQ COMMAND 'TRACEOUT))
	  ((LAMBDA (*GLOBAL-DEMONS*) (CATCH 'RESUME-PROGRAM
	      (LOOP
		(EXECUTE-OPTION 'COMMAND *BREAK-OPTIONS*) ) ) )
	    '((22 . TOGGLE-INSERT))) )
	BREAK )
      (CLEAR-STATUS "Debug")
      (DEBUG-FREE)
      (LOOP
	(SETQ *BACKTRACE*)
	(EXECUTE-OPTION 'COMMAND *DEBUG-OPTIONS*) ) )
    (UPDATE-STATE '(FUNCTION BREAK
	*TRACE-HISTORY* *DEBUG-MODE* *BACKTRACE* *DEBUG-ROW* *PRINT-TRACE*)) ) )

(SETQ *DEBUG-OPTIONS* '(
	("Author" . DEBUG-AUTHOR)
	("Delete" . DELETE-TEXT-FILE)
	("hElp" . DEBUG-HELP)
	("History" . TRACE-HISTORY)
	("Load" . LOAD-SOURCE-FILE)
	("Mode" . DEBUG-MODE)
	("Options" . (
		("Color" . (
			("Menu" . SET-MENU-COLOR)
			("Work" . SET-WORK-COLOR) ))
		("Display" . SET-DISPLAY)
		("Execute" . GO-DOS)
		("Mute" . SET-MUTE) ))
	("Print" . (
		("Printer" . PRINT-FILE-PRINTER)
		("Layout" . PRINT-FILE-LAYOUT)
		("Options" . PRINT-FILE-OPTIONS) ))
	("Quit" . QUIT-PROGRAM)
	("Trace" . TRACE-FUNCTION)
	("traceIn" . TRACEIN-FUNCTION)
	("Untrace" . (
		("All" . UNTRACE-ALL)
		("One" . UNTRACE-FUNCTION) ))
	("Window" . CHANGE-WINDOW) ))

(SETQ *BREAK-OPTIONS* (DELETE-IF '(LAMBDA (OPTION)
				    (MEMBER (CAR OPTION) '("Quit" "Window")))
				 (COPY-LIST *DEBUG-OPTIONS*)))
(SETQ *BREAK-OPTIONS*
	(MERGE '(("Backtrace" . BACKTRACE) ("Resume" . RESUME-PROGRAM))
		*BREAK-OPTIONS*
		'(LAMBDA (OPT1 OPT2) (STRING< (CAR OPT1) (CAR OPT2))) ))


(IF (NOT (GETD 'PRINT-FILE-PRINTER T))
    (MOVD 'NULL 'PRINT-FILE-PRINTER) )

(IF (NOT (GETD 'PRINT-FILE-LAYOUT T))
    (MOVD 'NULL 'PRINT-FILE-LAYOUT) )

(IF (NOT (GETD 'PRINT-FILE-OPTIONS T))
    (MOVD 'NULL 'PRINT-FILE-OPTIONS) )

(IF (NOT (GETD 'DELETE-TEXT-FILE T))
    (MOVD 'NULL 'DELETE-TEXT-FILE) )


(SETQ *HELP-FILE* "HELP.LSP")	; Set to path and file name of help file.

(DEFUN DEBUG-HELP (
    NAME)
  (SETQ NAME *HELP-FILE*)
  (LOOP
    ((PROBE-FILE NAME)
      (SETQ *HELP-FILE* NAME)
      ( ((GETD 'HELP-NAME 0))
	(PROMPT-WINDOW)
	(LOAD *HELP-FILE*) )
      (SETQ NAME (PROMPT-INPUT "Enter function or variable name" "HELP name: "))
      ((EQ *LINE-TERMINATOR* 27)  NIL)
      ((EQ STRING "")  NIL)
      ((SETQ NAME (HELP-NAME NAME))
	(LOOP
	  (OPTION-WINDOW 0)
	  (WRITE-STRING NAME)
	  ((NOT (PROMPT-YN "Display next name")))
	  ((NOT (SETQ NAME (NEXT-HELP-NAME)))) ) ) )
    (ERROR-BEEP)
    ((EQ (SETQ NAME (PROMPT-TEXT-FILE *HELP-FILE* 'LSP)) "")) ) )


(DEFUN LOAD-SOURCE-FILE (
    FILE-NAME EXPN)
  (LOOP
    (SETQ FILE-NAME (PROMPT-TEXT-FILE "" 'LSP))
    ((EQ FILE-NAME "") NIL)
    (SHOW-PROMPT "Press ESC to abort")
    (CURRENT-DEBUG-WINDOW)
    (TERPRI)
    (CURSOR-ON)
    (SETQ EXPN ((LAMBDA (*AUTO-NEWLINE* *INTERRUPT-HOOK*)
		  (CATCH NIL (LOAD FILE-NAME *SHOW-LOAD*))) T 'CONSOLE-INTERRUPT))
    (CURSOR-OFF)
    (DEBUG-ROW)
    (DEBUG-FREE)
    ((IDENTITY EXPN))
    (ERROR-BEEP) ) )

(DEFUN DEBUG-AUTHOR (
    STRING *PRINTER-ECHO*)
  (LOOP
    (SETQ STRING (PROMPT-INPUT "Enter form for evaluation" "AUTHOR form: "))
    ((EQ *LINE-TERMINATOR* 27)	NIL)
    ((EQ STRING "")  NIL)
    (SHOW-PROMPT "Press ESC to abort")
    (CURRENT-DEBUG-WINDOW)
    (TERPRI 2 T)
    (WRITE-STRING "$ " T)
    (CURSOR-ON)
    ((LAMBDA (*AUTO-NEWLINE* *INTERRUPT-HOOK*) (CATCH NIL
	(WRITE-LINE STRING T)
	(DEBUG-ROW)
	(SETQ - (READ-FROM-STRING (PACK* STRING "]")))
	(PSETQ * (UNWIND-PROTECT (EVAL -) (SETQ +++ ++	++ +  + -))
	       *** **
	       ** *)
	(FRESH-LINE T)
	(WRITE * T) ))
	      T 'CONSOLE-INTERRUPT)
    (CURSOR-OFF)
    (DEBUG-ROW)
    (DEBUG-FREE)
    (SETQ *TRACE-HISTORY* (FOURTH (WINDOW-STATE))) ) )

(DEFUN RESUME-PROGRAM ()
  (THROW 'RESUME-PROGRAM) )


(DEFUN TRACE-FUNCTION (
    NAME)
  (LOOP
    (SETQ NAME (STRING-UPCASE (PROMPT-INPUT "Enter function name"
					    "TRACE function: ")))
    ((EQ *LINE-TERMINATOR* 27)	NIL)
    ((EQ NAME "")  NIL)
    ((AND (EQ (GETD NAME T) 'LAMBDA)
	  (CONSP (GETD NAME))
	  (NOT (MEMBER NAME *DEBUG-FUNCTIONS*)))
      (PUSH NAME *DEBUG-FUNCTIONS*)
      (PUTD NAME (MAKE-TRACE-BODY NAME (GETD NAME))) )
    ((OR (MEMBER NAME *SPECIAL-FORMS*)
	 (AND (EQ (GETD NAME T) 'LAMBDA)
	      (NOT (MEMBER NAME *DEBUG-FUNCTIONS*))))
      (TRACEIN-FUNCTION-AUX NAME) )
    (ERROR-BEEP) ) )

(DEFUN TRACEIN-FUNCTION (
    NAME)
  (LOOP
    (SETQ NAME (STRING-UPCASE (PROMPT-INPUT "Enter function name"
					    "TRACE function: ")))
    ((EQ *LINE-TERMINATOR* 27)	NIL)
    ((EQ NAME "")  NIL)
    ((OR (MEMBER NAME *SPECIAL-FORMS*)
	 (AND (EQ (GETD NAME T) 'LAMBDA)
	      (NOT (MEMBER NAME *DEBUG-FUNCTIONS*))))
      (TRACEIN-FUNCTION-AUX NAME) )
    (ERROR-BEEP) ) )

(DEFUN TRACEIN-FUNCTION-AUX (NAME
    TMP)
  (LOOP
    (SETQ TMP (STRING-UPCASE (PROMPT-INPUT "Enter function name"
				(PACK* "Trace " NAME " in function: "))))
    ((EQ *LINE-TERMINATOR* 27)	NIL)
    ((EQ TMP "")  NIL)
    ((AND (EQ (GETD TMP T) 'LAMBDA)
	  (CONSP (GETD TMP))
	  (NOT (MEMBER (CONS NAME TMP) *DEBUG-FUNCTIONS* 'EQUAL)))
      (PUSH (CONS NAME TMP) *DEBUG-FUNCTIONS*)
      (PUTD TMP (SUBST (PACK* NAME "!D") NAME (GETD TMP)))
;     ((GETD (PACK* NAME "!D")))
      (PUTD (PACK* NAME "!D")
	    (MAKE-TRACE-BODY NAME
			     (IF (MEMBER NAME *SPECIAL-FORMS*)
				 (GETD (PACK* NAME "!D"))
				 (LIST 'LAMBDA 'LST
				    (LIST 'APPLY (LIST 'QUOTE NAME) 'LST)) ))) )
    (ERROR-BEEP) ) )

(DEFUN MAKE-TRACE-BODY (NAME BODY)
  (LIST (FIRST BODY)
	(SECOND BODY)
	(LIST 'DEBUG-WINDOW
	      '(QUOTE TRACEIN)
	      (LIST 'QUOTE NAME)
	      (IF (ATOM (SECOND BODY)) (SECOND BODY) (CONS 'LIST (SECOND BODY)))
	      (LIST 'QUOTE (WINDOW-STATE)))
	(LIST 'DEBUG-WINDOW
	      '(QUOTE TRACEOUT)
	      (LIST 'QUOTE NAME)
	      (CONS 'PROGN (CDDR BODY))
	      (LIST 'QUOTE (WINDOW-STATE)))) )

(DEFUN UNTRACE-ALL ()
  (MAPC 'UNTRACE-FUNCTION-AUX *DEBUG-FUNCTIONS*)
  0 )

(DEFUN UNTRACE-FUNCTION (
    NAME TMP)
  (LOOP
    (SETQ NAME (STRING-UPCASE (PROMPT-INPUT "Enter function name"
					    "UNTRACE function: ")))
    ((EQ *LINE-TERMINATOR* 27)	NIL)
    ((EQ NAME "")  NIL)
    ((MEMBER NAME *DEBUG-FUNCTIONS*)
      (UNTRACE-FUNCTION-AUX NAME) )
    ((ASSOC NAME *DEBUG-FUNCTIONS*)
      (LOOP
	(SETQ TMP (STRING-UPCASE (PROMPT-INPUT "Enter function name"
				(PACK* "Untrace " NAME " in function: "))))
	((EQ *LINE-TERMINATOR* 27)  NIL)
	((EQ TMP "")  NIL)
	((MEMBER (CONS NAME TMP) *DEBUG-FUNCTIONS* 'EQUAL)
	  (UNTRACE-FUNCTION-AUX (CONS NAME TMP)) )
	(ERROR-BEEP) ) )
    (ERROR-BEEP) ) )

(DEFUN UNTRACE-FUNCTION-AUX (NAME
    TMP BODY)
  (SETQ *DEBUG-FUNCTIONS* (DELETE NAME *DEBUG-FUNCTIONS* 'EQUAL))
  ((ATOM NAME)
    (SETQ BODY (GETD NAME))
    (PUTD NAME (LIST* 'LAMBDA (SECOND BODY) (CDR (FOURTH (FOURTH BODY))))) )
  (SETQ TMP (CDR NAME)
	NAME (CAR NAME)
	BODY (GETD (PACK* NAME "!D")))
  (PUTD TMP (SUBST NAME (PACK* NAME "!D") (GETD TMP)))
  ((ASSOC NAME *DEBUG-FUNCTIONS*))
  ((MEMBER NAME *SPECIAL-FORMS*))
  (REMD (PACK* NAME "!D")) )


(SETQ *SPECIAL-FORMS* '(SETQ INCQ DECQ))

(PUTD 'SETQ!D '(NLAMBDA LST!D
  (LOOP
    ((NULL (CDDR LST!D))
      (SET (POP LST!D) (EVAL (POP LST!D))) )
    (SET (POP LST!D) (EVAL (POP LST!D))) ) ))

(PUTD 'INCQ!D '(NLAMBDA LST!D
  (SET (CAR LST!D)
       (+ (EVAL (CAR LST!D)) (IF (CDR LST!D) (EVAL (CADR LST!D)) 1))) ))

(PUTD 'DECQ!D '(NLAMBDA LST!D
  (SET (CAR LST!D)
       (- (EVAL (CAR LST!D)) (IF (CDR LST!D) (EVAL (CADR LST!D)) 1))) ))


(DEFUN DEBUG-WINDOW (COMMAND FUNCTION BREAK STATE
    WINDOW PANE ROW COL FOREGROUND-COLOR BACKGROUND-COLOR)
  (SETQ WINDOW (POSITION-IF '(LAMBDA (WINDOW)
			       (SETQ PANE (POSITION STATE (SECOND WINDOW))) )
			    *WINDOWS*))
  ( ((EQ COMMAND 'TRACEOUT)			;(POP *BACKTRACE*)
      (REPLACE-NTH (CDR (NTH 5 STATE)) STATE 5) ) )
  (REPLACE-NTH					;(PUSH TRACE *TRACE-HISTORY*)
     (CONS (LIST FUNCTION BREAK (LENGTH (NTH 5 STATE)) COMMAND) (NTH 3 STATE))
     STATE 3)
  (DELETE-NTH (NTH 3 STATE) *HISTORY-LENGTH*)
  ( ((EQ COMMAND 'TRACEIN)			;(PUSH TRACE *BACKTRACE*)
      (REPLACE-NTH (CONS (LIST FUNCTION BREAK (LENGTH (NTH 5 STATE)))
			 (NTH 5 STATE)) STATE 5) ) )
  ((NEQ PANE (WINDOW-PANE WINDOW)) BREAK)
  (SETQ ROW (ROW)
	COL (COLUMN)
	FOREGROUND-COLOR (FOREGROUND-COLOR)
	BACKGROUND-COLOR (BACKGROUND-COLOR)
	*CONSOLE-BREAK* NIL
	BREAK ((LAMBDA (*CURRENT-WINDOW* *INTERRUPT-HOOK*)
		  (APPLY "Debug" COMMAND FUNCTION BREAK (NTHCDR 3 STATE)) )
		WINDOW (IF *INTERRUPT-HOOK* 'INTERRUPT-HOOK)))
  (CURRENT-WINDOW)
  (FOREGROUND-COLOR FOREGROUND-COLOR)
  (BACKGROUND-COLOR BACKGROUND-COLOR)
  (IF (NEQ STATE (WINDOW-STATE))
      (SET-CURSOR ROW COL) )
  (IF *CONSOLE-BREAK* (FUNCALL *INTERRUPT-HOOK*))
  (SETQ *CONSOLE-BREAK*)
  BREAK )

(DEFUN INTERRUPT-HOOK ()
  (SETQ *CONSOLE-BREAK* T) )

(DEFUN TRACE-HISTORY ()
  ((NULL *TRACE-HISTORY*))
  (CURRENT-DEBUG-WINDOW)
  (TERPRI)
  (MAPC 'DISPLAY-TRACE (REVERSE *TRACE-HISTORY*))
  (DEBUG-ROW) )

(DEFUN BACKTRACE ()
  ((NULL *BACKTRACE*))
  (CURRENT-DEBUG-WINDOW)
  (TERPRI)
  (MAPC 'DISPLAY-TRACE (REVERSE *BACKTRACE*))
  (DEBUG-ROW) )


(DEFUN DISPLAY-TRACE (TRACE
    *AUTO-NEWLINE* *PRINTER-ECHO*)
  (SETQ *AUTO-NEWLINE* T
	*PRINTER-ECHO* *PRINT-TRACE*)
  (TERPRI)
  (SPACES (* (THIRD TRACE) 2))
  (PRINC (FIRST TRACE))
  (WRITE-STRING " ")
  ( ((EQ (FOURTH TRACE) 'TRACEOUT)
      (WRITE-STRING "= ")
      (PRIN1 (SECOND TRACE)) )
    (WRITE-STRING "[")
    (PRIN1 (CAR (SECOND TRACE)))
    (MAPC '(LAMBDA (EXPN) (WRITE-STRING ", ") (PRIN1 EXPN))
	  (CDR (SECOND TRACE)))
    (WRITE-STRING "]") )
  ((LISTEN T)
    ((EQ (READ-BYTE T) 19)
      (LOOP
	((READ-BYTE T)) ) )
    (UNREAD-CHAR T) ) )


(DEFUN DEBUG-MODE ()
; Selects debug mode and printing of traces.
  (RPLACA (CAR DEBUG-MODE) *DEBUG-MODE*)
  (RPLACA (CADR DEBUG-MODE) (IF *PRINT-TRACE* "Yes" "No"))
  ((MODE-QUERY DEBUG-MODE)
    (SETQ *DEBUG-MODE* (CAAR DEBUG-MODE)
	  *PRINT-TRACE* (EQ (CAADR DEBUG-MODE) "Yes"))
    (REPLACE-NTH *DEBUG-MODE* (WINDOW-STATE) 4)
    (REPLACE-NTH *PRINT-TRACE* (WINDOW-STATE) 7) ) )

(SETQ DEBUG-MODE '(
  ("Continuous" "Select trace mode" "Trace" ("Continuous" "Step" "Off"))
  ("" "Echo function traces to printer" "Echo" ("Yes" "No")) ))


(DEFUN DEBUG-ROW ()
  (REPLACE-NTH (SETQ *DEBUG-ROW* (ROW)) (WINDOW-STATE) 6) )

(DEFUN CURRENT-DEBUG-WINDOW ()
  (CURRENT-WINDOW)
  (SET-CURSOR *DEBUG-ROW* 0) )


(DEFUN DEBUG-FREE ()
  ((SMALL-SCREENP))
  (STATUS-WINDOW)
  (SET-CURSOR 0 31)
  (WRITE-STRING "Data:	   Code:" T)
  (SET-CURSOR 0 36)
  (PRIN1 (APPLY 'MIN *FREE-SPACE*) T)
  (WRITE-STRING "% " T)
  (SET-CURSOR 0 46)
  (PRIN1 (TRUNCATE (+ (- 57000 (DSMEMORY 36 NIL T)) (DSMEMORY 34 NIL T)) 570) T)
  (WRITE-STRING "% " T) )


(OR (GETD 'WINDOWS T)
    (LOAD "WINDOWS.LSP")
    (SOME '(LAMBDA (FILE)
	     (SETQ FILE (NREVERSE (UNPACK FILE)))
	     (LOAD (PACK (NREVERSE (OR (MEMBER '\\ FILE) (MEMBER ': FILE))
				   (LIST "WINDOWS.LSP")))) )
	  (INPUT-FILES) )
    (TERPRI NIL T)
    (WRITE-LINE "Cannot find WINDOWS.LSP" T) )
